home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / jackal1a.lha / jacal / ext.scm < prev    next >
Encoding:
Text File  |  1992-12-24  |  6.0 KB  |  182 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;;; An algebraic extension is the root of a polynomial with more than
  6. ;;; one distinct value.  These values are not linked;  the difference
  7. ;;; between two algebraic extensions which are roots of identical
  8. ;;; polynomials is not 0.  Radicals have an additional rule that
  9. ;;; exponents of "positive" radicands commute.  For instance:
  10. ;;; (x^2)^(1/2) ==> x.  Notice that ((-x)^2)^(1/2) ==> x also.
  11. ;;; (-x^2)^(1/2) ==> (-1)^(1/2)*x.  Therefore "deep" squarefree
  12. ;;; factorization forms the backbone of radical simplification and
  13. ;;; denesting.  This seems to be a radical departure from previous work.
  14.  
  15. ;;; algebraic extensions
  16. ;;; we want to find all extensions used by this poly except this poly.
  17. (define (alg_exts poly)
  18.   (let ((elts '()))
  19.     (poly_for-each-var 
  20.      (lambda (v)
  21.        (let ((er (extrule v)))
  22.      (if (and er (not (eq? er poly)))
  23.          (set! elts (adjoin v elts)))))
  24.      poly)
  25.     elts))
  26.  
  27. ;;;alg_vars returns a list of all vars used in this or in extensions
  28. ;;;used in this.
  29. (define (alg_vars poly)
  30.   (let ((deps '()) (exts '()))
  31.     (poly_for-each-var
  32.      (lambda (v) (if (extrule v)
  33.              (set! exts (adjoin v exts))
  34.            (set! deps (adjoin v deps))))
  35.      poly)
  36.     (for-each (lambda (v) (set! deps (union (var_depends v) deps)))
  37.           exts)
  38.     deps))
  39.  
  40. (define (alg_square-free-var p var)
  41.   (alg_/ p (alg_gcd p (alg_diff p var))))
  42.  
  43. ;;; This is for equations
  44. ;;; Don't simplify a rule with itself
  45. (define (alg_simplify p)
  46.   (let ((exrls (map extrule (sort (alg_exts p) var_>))))
  47.     (if (memv p exrls)
  48.     p
  49.     (reduce-init poly_prem p exrls))))
  50.  
  51. (define (alg_clear-denoms p)
  52.   (do ((v (poly_find-var-if? (rat_denom p) extrule)
  53.       (poly_find-var-if? (rat_denom p) extrule))
  54.        (oldv "foo" (car v)))
  55.       ((not v) p)
  56.       (if (eq? (car v) oldv)
  57.       (eval-error "could not clear denominator of: " p))
  58.       (set! p (alg_simplify
  59.            (poly_* p (alg_conjugate (rat_denom p) v))))))
  60.  
  61. ;;; This generates conjugates for any algebraic by a wonderful theorem of mine.
  62. ;;; 4/30/90 jaffer
  63. (define (alg_conjugate poly extpoly)
  64.   (let* ((var (car extpoly))
  65.      (pdiv (univ_pdiv extpoly (promote var poly)))
  66.      (pquo (car pdiv))
  67.      (prem (cadr pdiv)))
  68.     (if (zero? (univ_degree prem var))
  69.     pquo
  70.       (poly_* pquo (alg_conjugate prem extpoly)))))
  71.  
  72. ;;;This currently works only for univ extpoly
  73. (define (alg_mod poly extpoly)
  74.   (let ((p (poly_prem poly extpoly)))
  75.     (if (and (rat? p) (pair? extpoly)
  76.          (pair? (rat_denom p)) (eq? (car extpoly) (car (rat_denom p))))
  77.     (poly_prem
  78.      (poly_* p (alg_conjugate (rat_denom p) extpoly))
  79.      extpoly)
  80.     p)))
  81.  
  82. ;;; This section attempts to implement an incremental version of
  83. ;;; Caviness, B.F., Fateman, R.:
  84. ;;; Simplification of Radical Expressions.
  85. ;;; SYMSAC 1976, 329-338
  86. ;;; as described in
  87. ;;; Buchberger, B., Collins, G.E., Loos, R.:
  88. ;;; Computer Algebra, Symbolic and Algebraic Computation. Second Edition
  89. ;;; Springer-Verlag/Wein 1983, 20-22
  90. ;;; This algorithm for canonical simplification of UNNESTED radical expressions
  91. ;;; also has the convention that (s * t)^r = s^r * t^r.
  92. ;;; If the variable LINK-RADICANDS is #f then a new multiple value expression
  93. ;;; is returned for each radical.
  94.  
  95. ;;; this is actually alg_depth
  96. (define (rad_depth imp)
  97.   (let ((exts (alg_exts imp)))
  98.     (if (null? exts)
  99.     0
  100.       (+ 1 (apply max (map (lambda (x) (rad_depth (extrule x))) exts))))))
  101.  
  102. ;;; Integer power of EXPR
  103. (define (ipow a pow)
  104.   (if (not (integer? pow)) (math-error "non-integer power? " pow))
  105.   (cond ((expl? a) (if (< pow 0)
  106.                (make-rat 1 (poly_^ a (- pow)))
  107.              (poly_^ a pow)))
  108.     ((rat? a) (if (< pow 0)
  109.               (make-rat (ipow (rat_denom a) (- pow))
  110.                 (ipow (rat_num a) (- pow)))
  111.             (make-rat (ipow (rat_num a) pow)
  112.                   (ipow (rat_denom a) pow))))
  113.     (else (if (< pow 0)
  114.           (app* (list _@ 1 (univ_monomial -1 (- pow) _@1)) a)
  115.         (app* (univ_monomial 1 pow _@1) a)))))
  116.  
  117. (define (^ a pow)
  118.   (cond
  119.    ((not (rat_number? pow)) (deferop '^ a pow))
  120.    ((eqn? a) (math-error "Expt of equation?: " a))
  121.    (else
  122.     (set! pow (expr_normalize pow))
  123.     (let ((tmp #f)
  124.       (expnum (num pow))
  125.       (expdenom (denom pow)))
  126.       (cond
  127.        ((eqv? 1 expdenom) (ipow a expnum))
  128.        (link-radicands
  129.     (set! a (expr_normalize a))
  130.     (cond ((expl? a) (ipow (make-radical-ext a expdenom) expnum))
  131.           ((not (rat? a)) (math-error "Non-rational radicand: " a))
  132.           ((rat_unit-denom? a)
  133.            (ipow (make-radical-ext (poly_* (denom a) (num a)) expdenom)
  134.              expnum))
  135.           (else (ipow (make-rat (make-radical-ext (rat_num a) expdenom)
  136.                     (make-radical-ext (rat_denom a) expdenom))
  137.               expnum))))
  138.        (else
  139.     (app* (cond ((> expnum 0)
  140.              (set! tmp (univ_monomial -1 expdenom _@))
  141.              (set-car! (cdr tmp) (univ_monomial 1 expnum _@1))
  142.              tmp)
  143.             (else
  144.              (set! tmp (univ_monomial
  145.                 (univ_monomial -1 (- expnum) _@1)
  146.                 expdenom
  147.                 _@))
  148.              (set-car! (cdr tmp) 1)
  149.              tmp))
  150.           a)))))))
  151.  
  152. ;;; Generate extensions for radicals of polynomials
  153. ;;; Currently this does not split previously defined radicands.
  154. ;;; It will as soon as expression rework is added.
  155. (define (make-radical-ext p r)
  156.   (set! p (licit->polxpr p))
  157.   (let ((prest #f)
  158.     (pegcd #f)
  159.     (radrest #f)
  160.     (en #f)
  161.     (e (member-if (lambda (e) (equal? p (cadr e))) radical-defs)))
  162.     (cond (e (if (divides? r (length (cddr (car e))))
  163.          (radpow (car e) r)
  164.          (var->expl (make-rad-var p r))))
  165.       ((begin (set! e (member-if (lambda (rule)
  166.                        (set! en (cadr rule))
  167.                        (set! pegcd (poly_gcd en p))
  168.                        (not (eqv? 1 pegcd)))
  169.                      radical-defs))
  170.           e)
  171.        (set! prest (poly_/ p pegcd))
  172.        (set! radrest (poly_/ en pegcd))
  173.        (if (and (eqv? 1 radrest) (divides? r (length (cddr (car e)))))
  174.            (app* _@1*@2 (make-radical-ext prest r) (radpow (car e) r))
  175.            (var->expl (make-rad-var p r))))
  176.       (else (var->expl (make-rad-var p r))))))
  177.  
  178. (define (radpow radrule r)
  179.   (univ_monomial 1 (quotient (length (cddr radrule)) r) (car radrule)))
  180.  
  181. ;;;    Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.
  182.